home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / schmooz.scm < prev    next >
Text File  |  1999-04-19  |  19KB  |  606 lines
  1. ;;; "schmooz.scm" Program for extracting texinfo comments from Scheme.
  2. ;;; Copyright (C) 1998 Radey Shouman and Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;$Header: /usr/local/cvsroot/slib/schmooz.scm,v 1.11 1998/12/19 02:02:54 jaffer Exp $
  21. ;;$Name:  $
  22.  
  23. ;;; REPORT an error or warning
  24. (define report
  25.   (lambda args
  26.     (display *scheme-source-name*)
  27.     (display ": In function `")
  28.     (display *procedure*)
  29.     (display "': ")
  30.     (newline)
  31.  
  32.     (display *derived-txi-name*)
  33.     (display ": ")
  34.     (display *output-line*)
  35.     (display ": warning: ")
  36.     (apply qreport args)))
  37.  
  38. (define qreport
  39.   (lambda args
  40.     (for-each (lambda (x) (write x) (display #\ )) args)
  41.     (newline)))
  42.  
  43. (require 'common-list-functions)    ;some
  44. (require 'string-search)
  45. (require 'fluid-let)
  46. (require 'line-i/o)            ;read-line
  47. (require 'filename)
  48. (require 'scanf)
  49. ;;(require 'debug) (set! *qp-width* 100) (define qreport qpn)
  50.  
  51. ;;; This allows us to test without generating files
  52. (define *scheme-source* (current-input-port))
  53. (define *scheme-source-name* "stdin")
  54. (define *derived-txi* (current-output-port))
  55. (define *derived-txi-name* "?")
  56.  
  57. (define *procedure* #f)
  58. (define *output-line* 0)
  59.  
  60. (define CONTLINE -80)
  61.  
  62. ;;; OUT indents and displays the arguments
  63. (define (out indent . args)
  64.   (cond ((>= indent 0)
  65.      (newline *derived-txi*)
  66.      (set! *output-line* (+ 1 *output-line*))
  67.      (do ((j indent (- j 8)))
  68.          ((> 8 j)
  69.           (do ((i j (- i 1)))
  70.           ((>= 0 i))
  71.         (display #\  *derived-txi*)))
  72.        (display #\     *derived-txi*))))
  73.   (for-each (lambda (a)
  74.           (cond ((symbol? a)
  75.              (display a *derived-txi*))
  76.             ((string? a)
  77.              (display a *derived-txi*)
  78. ;             (cond ((string-index a #\newline)
  79. ;                (set! *output-line* (+ 1 *output-line*))
  80. ;                (report "newline in string" a)))
  81.              )
  82.             (else
  83.              (display a *derived-txi*))))
  84.         args))
  85.  
  86. ;; LINE is a string, ISTRT the index in LINE at which to start.
  87. ;; Returns a list (next-char-number . list-of-tokens).
  88. ;; arguments look like:
  89. ;;    "(arg1 arg2)"  or "{arg1,arg2}" or the whole line is split
  90. ;; into whitespace separated tokens.
  91. (define (parse-args line istrt)
  92.   (define (tok1 istrt close sep? splice)
  93.     (let loop-args ((istrt istrt)
  94.             (args '()))
  95.       (let loop ((iend istrt))
  96.     (cond ((>= iend (string-length line))
  97.            (if close
  98.            (slib:error close "not found in" line)
  99.            (cons iend
  100.              (reverse 
  101.               (if (> iend istrt)
  102.                   (cons (substring line istrt iend) args)
  103.                   args)))))
  104.           ((eqv? close (string-ref line iend))
  105.            (cons (+ iend 1)
  106.              (reverse (if (> iend istrt)
  107.                   (cons (substring line istrt iend) args)
  108.                   args))))
  109.           ((sep? (string-ref line iend))
  110.            (let ((arg (and (> iend istrt)
  111.                    (substring line istrt iend))))
  112.          (if (equal? arg splice)
  113.              (let ((rest (tok1 (+ iend 1) close sep? splice)))
  114.                (cons (car rest)
  115.                  (append args (cadr rest))))
  116.              (loop-args (+ iend 1)
  117.                 (if arg
  118.                     (cons arg args)
  119.                     args)))))
  120.           (else
  121.            (loop (+ iend 1)))))))
  122.   (let skip ((istrt istrt))
  123.     (cond ((>= istrt (string-length line)) (cons istrt '()))
  124.       ((char-whitespace? (string-ref line istrt))
  125.        (skip (+ istrt 1)))
  126.       ((eqv? #\{ (string-ref line istrt))
  127.        (tok1 (+ 1 istrt) #\} (lambda (c) (eqv? c #\,)) #f))
  128.       ((eqv? #\( (string-ref line istrt))
  129.        (tok1 (+ 1 istrt) #\) char-whitespace? "."))
  130.       (else 
  131.        (tok1 istrt #f char-whitespace? #f)))))
  132.  
  133.  
  134. ;; Substitute @ macros in string LINE.
  135. ;; Returns a list, the first element is the substituted version
  136. ;; of LINE, the rest are lists beginning with '@dfn or '@args
  137. ;; and followed by the arguments that were passed to those macros.
  138. ;; MACS is an alist of (macro-name . macro-value) pairs.
  139. (define (substitute-macs line macs)
  140.   (define (get-word i)
  141.     (let loop ((j (+ i 1)))
  142.       (cond ((>= j (string-length line))
  143.          (substring line i j))
  144.         ((or (char-alphabetic? (string-ref line j))
  145.          (char-numeric? (string-ref line j)))
  146.          (loop (+ j 1)))
  147.         (else (substring line i j)))))
  148.   (let loop ((istrt 0)
  149.          (i 0)
  150.          (res '()))
  151.     (cond ((>= i (string-length line))
  152.        (list
  153.         (apply string-append 
  154.            (reverse 
  155.             (cons (substring line istrt (string-length line))
  156.               res)))))
  157.       ((char=? #\@ (string-ref line i))
  158.        (let* ((w (get-word i))
  159.           (symw (string->symbol w)))
  160.          (cond ((eq? '@cname symw)
  161.             (let ((args (parse-args 
  162.                  line (+ i (string-length w)))))
  163.               (cond ((and args (= 2 (length args)))
  164.                  (loop (car args) (car args)
  165.                    (cons
  166.                     (string-append
  167.                      "@code{" (cadr args) "}")
  168.                     (cons (substring line istrt i) res))))
  169.                 (else
  170.                  (report "@cname wrong number of args" line)
  171.                  (loop istrt (+ i (string-length w)) res)))))
  172.            ((eq? '@dfn symw)
  173.             (let* ((args (parse-args
  174.                   line (+ i (string-length w))))
  175.                (inxt (car args))
  176.                (rest (loop inxt inxt
  177.                        (cons (substring line istrt inxt)
  178.                          res))))
  179.               (cons (car rest)
  180.                 (cons (cons '@dfn (cdr args))
  181.                   (cdr rest)))))
  182.            ((eq? '@args symw)
  183.             (let* ((args (parse-args
  184.                   line (+ i (string-length w))))
  185.                (inxt (car args))
  186.                (rest (loop inxt inxt res)))
  187.               (cons (car rest)
  188.                 (cons (cons '@args (cdr args))
  189.                   (cdr rest)))))
  190.            ((assq symw macs) =>
  191.             (lambda (s)
  192.               (loop (+ i (string-length w))
  193.                 (+ i (string-length w))
  194.                 (cons (cdr s)
  195.                   (cons (substring line istrt i) res)))))
  196.            (else (loop istrt (+ i (string-length w)) res)))))
  197.       (else (loop istrt (+ i 1) res)))))
  198.  
  199.  
  200. (define (sexp-def sexp)
  201.   (and (pair? sexp)
  202.        (memq (car sexp) '(DEFINE DEFVAR DEFCONST DEFINE-SYNTAX DEFMACRO))
  203.        (car sexp)))
  204.  
  205. (define def->var-name cadr)
  206.  
  207. (define (def->args sexp)
  208.   (define name (cadr sexp))
  209.   (define (body forms)
  210.     (if (pair? forms)
  211.     (if (null? (cdr forms))
  212.         (form (car forms))
  213.         (body (cdr forms)))
  214.     #f))
  215.   (define (form sexp)
  216.     (if (pair? sexp)
  217.     (case (car sexp)
  218.       ((LAMBDA) (cons name (cadr sexp)))
  219.       ((BEGIN) (body (cdr sexp)))
  220.       ((LET LET* LETREC)
  221.        (if (or (null? (cadr sexp))
  222.            (pair? (cadr sexp)))
  223.            (body (cddr sexp))
  224.            (body (cdddr sexp))))    ;named LET
  225.       (else #f))
  226.     #f))
  227.   (case (car sexp)
  228.     ((DEFINE) (if (pair? name)
  229.           name
  230.           (form (caddr sexp))))
  231.     ((DEFINE-SYNTAX) '())
  232.     ((DEFMACRO) (cons (cadr sexp) (caddr sexp)))
  233.     ((DEFVAR DEFCONST) #f)
  234.     (else (slib:error 'schmooz "doesn't look like definition" sexp))))
  235.  
  236. ;; Generate alist of argument macro definitions.
  237. ;; If ARGS is a symbol or string, then the definitions will be used in a 
  238. ;; `defvar', if ARGS is a (possibly improper) list, they will be used in
  239. ;; a `defun'.
  240. (define (scheme-args->macros args)
  241.   (define (arg->string a)
  242.     (if (string? a) a (symbol->string a)))
  243.   (define (arg->macros arg i)
  244.     (let ((s (number->string i))
  245.       (m (string-append "@var{" (arg->string arg) "}")))
  246.       (list (cons (string->symbol (string-append "@" s)) m)
  247.         (cons (string->symbol (string-append "@arg" s)) m))))
  248.   (let* ((fun? (pair? args))
  249.      (arg0 (if fun? (car args) args))
  250.      (args (if fun? (cdr args) '())))
  251.     (let ((m0 (string-append
  252.            (if fun? "@code{" "@var{") (arg->string arg0) "}")))
  253.       (append 
  254.        (list (cons '@arg0 m0) (cons '@0 m0))
  255.        (let recur ((i 1)
  256.            (args args))
  257.      (cond ((null? args) '())
  258.            ((or (symbol? args)        ;Rest list
  259.             (string? args))
  260.         (arg->macros args i))
  261.            (else
  262.         (append (arg->macros (car args) i)
  263.             (recur (+ i 1) (cdr args))))))))))
  264.  
  265. ;; Extra processing to be done for @dfn 
  266. (define (out-cindex arg)
  267.   (out 0 "@cindex " arg))
  268.  
  269. ;; ARGS looks like the cadr of a function definition:
  270. ;; (fun-name arg1 arg2 ...)
  271. (define (schmooz-fun defop args body xdefs)
  272.   (define (out-header args op)
  273.     (let ((fun (car args))
  274.       (args (cdr args)))
  275.       (out 0 #\@ op #\space fun)
  276.       (let loop ((args args))
  277.     (cond ((null? args))
  278.           ((symbol? args)
  279.            (loop (symbol->string args)))
  280.           ((string? args)
  281.            (out CONTLINE " "
  282.             (let ((n (- (string-length args) 1)))
  283.               (if (eqv? #\s (string-ref args n))
  284.               (substring args 0 n)
  285.               args))
  286.             " @dots{}"))
  287.           ((pair? args)
  288.            (out CONTLINE " " 
  289.             (if (or (eq? '... (car args))
  290.                 (equal? "..." (car args)))
  291.             "@dots{}"
  292.             (car args)))
  293.            (loop (cdr args)))
  294.           (else (slib:error 'schmooz-fun args))))))
  295.   (let* ((mac-list (scheme-args->macros args))
  296.      (ops (case defop
  297.            ((DEFINE-SYNTAX) '("defspec" . "defspecx"))
  298.            ((DEFMACRO) '("defmac" . "defmacx"))
  299.            (else '("defun" . "defunx")))))
  300.     (out-header args (car ops))
  301.     (let loop ((xdefs xdefs))
  302.       (cond ((pair? xdefs)
  303.          (out-header (car xdefs) (cdr ops))
  304.          (loop (cdr xdefs)))))
  305.     (for-each (lambda (subl)
  306.         (out 0 (car subl))
  307.         (for-each (lambda (l)
  308.                 (case (car l)
  309.                   ((@dfn)
  310.                    (out-cindex (cadr l)))
  311.                   ((@args)
  312.                    (out-header 
  313.                 (cons (car args) (cdr l))
  314.                 (cdr ops)))))
  315.               (cdr subl)))
  316.           (map (lambda (bl)
  317.              (substitute-macs bl mac-list))
  318.            body))
  319.     (out 0 "@end " (car ops))
  320.     (out 0)))
  321.  
  322. (define (schmooz-var defop name body xdefs)
  323.   (let* ((mac-list (scheme-args->macros name)))
  324.     (out 0 "@defvar " name)
  325.     (let loop ((xdefs xdefs))
  326.       (cond ((pair? xdefs)
  327.          (out 0 "@defvarx " (car xdefs))
  328.          (loop (cdr xdefs)))))
  329.     (for-each (lambda (subl)
  330.         (out 0 (car subl))
  331.         (for-each (lambda (l)
  332.                 (case (car l)
  333.                   ((@dfn) (out-cindex (cadr l)))
  334.                   (else
  335.                    (report "bad macro" l))))
  336.               (cdr subl)))
  337.           (map (lambda (bl)
  338.              (substitute-macs bl mac-list))
  339.            body))
  340.     (out 0 "@end defvar")
  341.     (out 0)))
  342.  
  343. ;;; SCHMOOZ files.
  344. (define schmooz
  345.   (let* ((scheme-file? (filename:match-ci?? "*??scm"))
  346.      (txi-file? (filename:match-ci?? "*??txi"))
  347.      (texi-file? (let ((tex? (filename:match-ci?? "*??tex"))
  348.                (texi? (filename:match-ci?? "*??texi")))
  349.                (lambda (filename) (or (txi-file? filename)
  350.                           (tex? filename)
  351.                           (texi? filename)))))
  352.      (txi->scm (filename:substitute?? "*txi" "*scm"))
  353.      (scm->txi (filename:substitute?? "*scm" "*txi")))
  354.     (define (schmooz-texi-file file)
  355.       (call-with-input-file file
  356.     (lambda (port)
  357.       (do ((pos (find-string-from-port? "@include" port)
  358.             (find-string-from-port? "@include" port)))
  359.           ((not pos))
  360.         (let ((fname #f))
  361.           (cond ((not (eqv? 1 (fscanf port " %s" fname))))
  362.             ((not (txi-file? fname)))
  363.             ((not (file-exists? (txi->scm fname))))
  364.             (else (schmooz (txi->scm fname)))))))))
  365.     (define (schmooz-scm-file file txi-name)
  366.       (display "Schmoozing ") (write file)
  367.       (display " -> ") (write txi-name) (newline)
  368.       (fluid-let ((*scheme-source* (open-file file "r"))
  369.           (*scheme-source-name* file)
  370.           (*derived-txi* (open-file txi-name "w"))
  371.           (*derived-txi-name* txi-name))
  372.     (set! *output-line* 1)
  373.     (schmooz-tops schmooz-top)
  374.     (close-input-port *scheme-source*)
  375.     (close-output-port *derived-txi*)))
  376.     (lambda files
  377.       (for-each (lambda (file)
  378.           (define sl (string-length file))
  379.           (cond ((scheme-file? file)
  380.              (schmooz-scm-file
  381.               file (scm->txi file)))
  382.             ((texi-file? file) (schmooz-texi-file file))))
  383.         files))))
  384.  
  385. ;;; SCHMOOZ-TOPS - schmooz top level forms.
  386. (define (schmooz-tops schmooz-top)
  387.   (let ((doc-lines '())
  388.     (doc-args #f))
  389.     (define (skip-ws line istrt)
  390.       (do ((i istrt (+ i 1)))
  391.       ((or (>= i (string-length line))
  392.            (not (memv (string-ref line i)
  393.               '(#\space #\tab #\;))))
  394.        (substring line i (string-length line)))))
  395.  
  396.     (define (tok1 line)
  397.       (let loop ((i 0))
  398.     (cond ((>= i (string-length line)) line)
  399.           ((or (char-whitespace? (string-ref line i))
  400.            (memv (string-ref line i) '(#\; #\( #\{)))
  401.            (substring line 0 i))
  402.           (else (loop (+ i 1))))))
  403.  
  404.     (define (read-cmt-line)
  405.       (cond ((eqv? #\; (peek-char *scheme-source*))
  406.          (read-char *scheme-source*)
  407.          (read-cmt-line))
  408.         (else (read-line *scheme-source*))))
  409.  
  410.     (define (lp c)
  411.       (cond ((eof-object? c)
  412.          (cond ((pair? doc-lines)
  413.             (report "No definition found for @body doc lines"
  414.                 (reverse doc-lines)))))
  415.         ((eqv? c #\newline)
  416.          (read-char *scheme-source*)
  417.          (set! *output-line* (+ 1 *output-line*))
  418.          (newline *derived-txi*)
  419.          (lp (peek-char *scheme-source*)))
  420.         ((char-whitespace? c)
  421.          (write-char (read-char *scheme-source*) *derived-txi*)
  422.          (lp (peek-char *scheme-source*)))
  423.         ((char=? c #\;)
  424.          (c-cmt c))
  425.         (else 
  426.          (sx))))
  427.  
  428.     (define (sx)
  429.       (let* ((s1 (read *scheme-source*))
  430.          ;;Read all forms separated only by single newlines
  431.          ;;and trailing whitespace.
  432.          (ss (let recur ()
  433.            (let ((c (peek-char *scheme-source*)))
  434.              (cond ((eqv? c #\newline)
  435.                 (read-char *scheme-source*)
  436.                 (if (eqv? #\( (peek-char *scheme-source*))
  437.                 (let ((s (read *scheme-source*)))
  438.                   (cons s (recur)))
  439.                 '()))
  440.                ((char-whitespace? c)
  441.                 (read-char *scheme-source*)
  442.                 (recur))
  443.                (else '()))))))
  444.     (cond ((eof-object? s1))
  445.           (else
  446.            (schmooz-top s1 ss (reverse doc-lines) doc-args)
  447.            (set! doc-lines '())
  448.            (set! doc-args #f)
  449.            (lp (peek-char *scheme-source*))))))
  450.  
  451.     (define (out-cmt line)
  452.       (let ((subl (substitute-macs line '())))
  453.     (newline *derived-txi*)
  454.     (display (car subl) *derived-txi*)
  455.     (for-each 
  456.      (lambda (l)
  457.        (case (car l)
  458.          ((@dfn)
  459.           (out-cindex (cadr l)))
  460.          (else 
  461.           (report "bad macro" line))))
  462.      (cdr subl))))
  463.  
  464.     ;;Comments not transcribed to generated Texinfo files.
  465.     (define (c-cmt c)
  466.       (cond ((eof-object? c) (lp c))
  467.         ((eqv? #\; c)
  468.          (read-char *scheme-source*)
  469.          (c-cmt (peek-char *scheme-source*)))
  470.         ;; Escape to start Texinfo comments
  471.         ((eqv? #\@ c)
  472.          (let* ((line (read-line *scheme-source*))
  473.             (tok (tok1 line)))
  474.            (cond ((or (string=? tok "@body")
  475.               (string=? tok "@text"))
  476.               (set! doc-lines 
  477.                 (cons (skip-ws line (string-length tok)) 
  478.                   doc-lines))
  479.               (body-cmt (peek-char *scheme-source*)))
  480.              ((string=? tok "@args")
  481.               (let ((args
  482.                  (parse-args line (string-length tok))))
  483.             (set! doc-args (cdr args))
  484.             (set! doc-lines
  485.                   (cons (skip-ws line (car args))
  486.                     doc-lines)))
  487.               (body-cmt (peek-char *scheme-source*)))
  488.              (else
  489.               (out-cmt (if (string=? tok "@")
  490.                    (skip-ws line 1)
  491.                    line))
  492.               (doc-cmt (peek-char *scheme-source*))))))
  493.         ;; Transcribe the comment line to C source file.
  494.         (else
  495.          (read-line *scheme-source*) ;(out-c-cmt )
  496.          (lp (peek-char *scheme-source*)))))
  497.  
  498.     ;;Comments incorporated in generated Texinfo files.
  499.     ;;Continue adding lines to DOC-LINES until a non-comment
  500.     ;;line is reached (may be a blank line).
  501.     (define (body-cmt c)
  502.       (cond ((eof-object? c) (lp c))
  503.         ((eqv? #\; c)
  504.          (set! doc-lines (cons (read-cmt-line) doc-lines))
  505.          (body-cmt (peek-char *scheme-source*)))
  506.         ((eqv? c #\newline)
  507.          (read-char *scheme-source*)
  508.          (lp (peek-char *scheme-source*)))
  509.         ;; Allow whitespace before ; in doc comments.
  510.         ((char-whitespace? c)
  511.          (read-char *scheme-source*)
  512.          (body-cmt (peek-char *scheme-source*)))
  513.         (else 
  514.          (lp (peek-char *scheme-source*)))))
  515.  
  516.     ;;Comments incorporated in generated Texinfo files.
  517.     ;;Transcribe comments to current position in Texinfo file
  518.     ;;until a non-comment line is reached (may be a blank line).
  519.     (define (doc-cmt c)
  520.       (cond ((eof-object? c) (lp c))
  521.         ((eqv? #\; c)
  522.          (out-cmt (read-cmt-line))
  523.            ;;(out-c-cmt (car ls))
  524.          (doc-cmt (peek-char *scheme-source*)))
  525.         ((eqv? c #\newline)
  526.          (read-char *scheme-source*)
  527.          (newline *derived-txi*)
  528.          (lp (peek-char *scheme-source*)))
  529.         ;; Allow whitespace before ; in doc comments.
  530.         ((char-whitespace? c)
  531.          (read-char *scheme-source*)
  532.          (doc-cmt (peek-char *scheme-source*)))
  533.         (else 
  534.          (newline *derived-txi*)
  535.          (lp (peek-char *scheme-source*)))))
  536.     (lp (peek-char *scheme-source*))))
  537.  
  538. (define (schmooz-top-doc-begin def1 defs doc proc-args)
  539.   (let ((op1 (sexp-def def1)))
  540.     (cond
  541.      ((not op1)
  542.       (or (null? doc)
  543.       (report "SCHMOOZ: no definition found for Texinfo documentation"
  544.           doc (car defs))))
  545.      (else
  546.       (let* ((args (def->args def1))
  547.          (args (if proc-args
  548.                (cons (if args (car args) (def->var-name def1))
  549.                  proc-args)
  550.                args)))
  551.     (let loop ((ss defs)
  552.            (smatch (list (or args (def->var-name def1)))))
  553.       (if (null? ss)
  554.           (let ((smatch (reverse smatch)))
  555.         ((if args schmooz-fun schmooz-var)
  556.             op1 (car smatch) doc (cdr smatch)))
  557.           (if (eq? op1 (sexp-def (car ss)))
  558.           (let ((a (def->args (car ss))))
  559.             (loop (cdr ss)
  560.               (if args
  561.                   (if a 
  562.                   (cons a smatch)
  563.                   smatch)
  564.                   (if a 
  565.                   smatch
  566.                   (cons (def->var-name (car ss))
  567.                     smatch)))))))))))))
  568.  
  569. ;;; SCHMOOZ-TOP - schmooz top level form sexp.
  570. (define (schmooz-top sexp1 sexps doc proc-args)
  571.   (cond ((not (pair? sexp1)))
  572.     ((pair? sexps)
  573.      (if (pair? doc)
  574.          (schmooz-top-doc-begin sexp1 sexps doc proc-args))
  575.      (set! doc '()))
  576.     (else
  577.      (case (car sexp1)
  578.        ((LOAD REQUIRE)        ;If you redefine load, you lose
  579.         #f)
  580.        ((BEGIN)
  581.         (schmooz-top (cadr sexp1) '() doc proc-args)
  582.         (set! doc '())
  583.         (for-each (lambda (s)
  584.             (schmooz-top s '() doc #f))
  585.               (cddr sexp1)))
  586.        ((DEFVAR DEFINE DEFCONST DEFINE-SYNTAX DEFMACRO)
  587.         (let* ((args (def->args sexp1))
  588.            (args (if proc-args
  589.                  (cons (if args (car args) (cadr sexp1))
  590.                    proc-args)
  591.                  args)))
  592.           (cond (args
  593.              (set! *procedure* (car args))
  594.              (cond ((pair? doc)
  595.                 (schmooz-fun (car sexp1) args doc '())
  596.                 (set! doc '()))))
  597.             (else
  598.              (cond ((pair? doc)
  599.                 (schmooz-var (car sexp1) (cadr sexp1) doc '())
  600.                 (set! doc '()))))))))))
  601.   (or (null? doc)
  602.       (report 
  603.        "SCHMOOZ: no definition found for Texinfo documentation"
  604.        doc sexp))
  605.   (set! *procedure* #f))
  606.